{*******************************************************************************
* The contents of this file are used with permission, subject to the Mozilla   *
* Public License Version 1.1 (the "License"); you may not use this file except *
* in compliance with the License. You may obtain a copy of the License at      *
* http://www.mozilla.org/MPL/                                                  *
*                                                                              *
* Software distributed under the License is distributed on an "AS IS" basis,   *
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for *
* the specific language governing rights and limitations under the License.    *
*                                                                              *
* The Original Code is distributed as part of the "mediate" product and is     *
* Copyright (C) @home media limited. All Rights Reserved.                      *
*                                                                              *
* Email: support@athomemedia.co.uk                                             *
* Web:   http://www.athomemedia.co.uk                                          *
*******************************************************************************}

unit DirectXSprite;

interface

uses Classes, Graphic, Colour, Direct3D9, Windows, AHMTypes;

type
  // Our custom vertex structure with untransformed (i.e. model space)
  // 3D coordinates, vertex colour and texture coordinates
  PCustomVertex = ^TCustomVertex;
  TCustomVertex = packed record
    X, Y, Z: Single;
    Colour: TD3DColor;
    Tu, Tv: Single;
  end;

  PQuadVertices = ^TQuadVertices;
  TQuadVertices = packed array[0..5] of TCustomVertex;

  TAHMDXQuadRenderer = class
  private
    FQuads: TList;
    FCachedVertex: Boolean;
    FQuadSize: Integer;
    FVertexSize: Integer;
    FVertexBuffer: IDirect3DVertexBuffer9;
    FCacheTexture: IDirect3DTexture9;
    procedure AllocateVertexBuffer;
    procedure ClearQuads;
  protected
    function CreateQuad: PQuadVertices;
    procedure RenderQuad(Quad: PQuadVertices; Texture: IDirect3DTexture9);
    procedure FlushRenders;
    procedure ClearVertexCache;
    procedure OnLostDevice;
    procedure OnResetDevice;
  public
    constructor Create;
    destructor Destroy; override;
  end;

  TAHMDXSprite = class
  private
    FAlphaBlending: Boolean;
    FMonochrome: Boolean;
    FWidth: Integer;
    FHeight: Integer;
    FTexture: IDirect3DTexture9;
    FTextureFmt: TD3DFormat;
    FValid: Boolean;
    FSurfaceHandle: HDC;
  protected
    FTextureWidth: Integer;
    FTextureHeight: Integer;
    function GetBounds: TAHMRect;
    function GetSourceRect: TAHMRectF;
  public
    constructor Create;
    destructor Destroy; override;
    property AlphaBlending: Boolean read FAlphaBlending write FAlphaBlending;
    property Monochrome: Boolean read FMonochrome write FMonochrome;
    property Width: Integer read FWidth;
    property Height: Integer read FHeight;
    property Available: Boolean read FValid;
    property Texture: IDirect3DTexture9 read FTexture write FTexture;
    property TextureFormat: TD3DFormat read FTextureFmt;
    property TextureWidth: Integer read FTextureWidth;
    property TextureHeight: Integer read FTextureHeight;
    property Valid: Boolean read FValid write FValid;
    property Bounds: TAHMRect read GetBounds;
    property SourceRect: TAHMRectF read GetSourceRect;
    property SurfaceHandle: HDC read FSurfaceHandle;
    procedure SetDimensions(Width, Height: Integer);
    function AllocateHandle: Boolean;
    procedure ReleaseHandle;
    function AllocateTexture: IDirect3DTexture9;
    function AllocateVideoTexture(Format: TD3DFormat; Pool: TD3DPool): IDirect3DTexture9;
    procedure ClearTexture;
    procedure SaveToFile(Filename: String);
  end;

  TAHMDXSpriteManager = class
  private
    FSpriteList: TList;
    FQuadRenderer: TAHMDXQuadRenderer;
    FInitialised: Boolean;
    FCachedWorld: Boolean;
    FCachedOriginX: Single;
    FCachedOriginY: Single;
    F3DRotation: Boolean;
    F3DRotnMatrix: TD3DMatrix;
    F3DOriginX: Single;
    F3DOriginY: Single;
    function GetDXSprite(Index: Integer): TAHMDXSprite;
    function GetCount: Integer;
  protected
    procedure ReleaseTextures;
  public
    constructor Create;
    destructor Destroy; override;
    property Count: Integer read GetCount;
    function CreateSprite: TAHMDXSprite; overload;
    function CreateSprite(Width, Height: Integer): TAHMDXSprite; overload;
    function CreateSpriteFromGraphic(Graphic: TAHMGraphic): TAHMDXSprite;
    function UpdateSprite(Sprite: TAHMDXSprite; BitmapData: TAHMBitmapData): Boolean;
    procedure FreeSprite(Sprite: TAHMDXSprite);
    procedure SetRotation(XOrigin, YOrigin: Single);
    procedure Set3DRotation(Rotation: TD3DMatrix);
    procedure Set3DTranslation(XOrigin, YOrigin: Single);
    procedure ResetRotation;
    procedure Reset3DRotation;
    procedure DrawSprite(Sprite: TAHMDXSprite; SrcRect, DestRect, ClipRect: TAHMRectF; Shade: TAHMCanvasShade;
                         Gamma: TAHMCanvasColour; XScale, YScale: Single; XFlip, YFlip, Clip: Boolean); overload;
    procedure DrawSprite(Sprite: TAHMDXSprite; SrcRect: TAHMRectF; X1, Y1, X2, Y2, X3, Y3, X4, Y4: Single;
                         Shade: TAHMCanvasShade; Gamma: TAHMCanvasColour); overload;
    procedure DrawPlainQuad(DestRect: TAHMRectF; Shade: TAHMCanvasShade; Gamma: TAHMCanvasColour;
                            XScale, YScale: Single); overload;
    procedure DrawPlainQuad(DestRect, ClipRect: TAHMRectF; Shade: TAHMCanvasShade; Gamma: TAHMCanvasColour;
                            XScale, YScale: Single); overload;
    procedure OnLostDevice;
    procedure OnResetDevice;
    procedure FlushSprites;
    procedure ReleaseResources;
    procedure BeginDrawing;
    procedure EndDrawing;
  end;


implementation

uses SysUtils, Math, D3DX9, DXErr9, ApplicationManager, DirectXHelper, Screen,
     Canvas, Logging;

const
  QUAD_CACHE_SIZE = 50; // Maximum quad render batch size

  // Our custom FVF, which describes our vertex structure (TCustomVertex)
  D3DFVF_CUSTOMVERTEX = (D3DFVF_XYZ or D3DFVF_DIFFUSE or D3DFVF_TEX1);

  // Initialise six vertices for rendering a quad (two triangles)
  EMPTY_QUAD: TQuadVertices = (
    (X: -1.0; Y:  1.0; Z: 0.0; Colour: $ffffffff; Tu: 1; Tv: 1 ),
    (X: -1.0; Y: -1.0; Z: 0.0; Colour: $ffffffff; Tu: 1; Tv: 0 ),
    (X:  1.0; Y: -1.0; Z: 0.0; Colour: $ffffffff; Tu: 0; Tv: 0 ),
    (X:  1.0; Y: -1.0; Z: 0.0; Colour: $ffffffff; Tu: 0; Tv: 0 ),
    (X:  1.0; Y:  1.0; Z: 0.0; Colour: $ffffffff; Tu: 0; Tv: 1 ),
    (X: -1.0; Y:  1.0; Z: 0.0; Colour: $ffffffff; Tu: 1; Tv: 1 )
  );


constructor TAHMDXQuadRenderer.Create;
begin
  inherited;

  FQuads := TList.Create;

  // Initialise size of our vertex and quad structures
  FVertexSize := SizeOf(TCustomVertex);
  FQuadSize := SizeOf(TQuadVertices);
end;

destructor TAHMDXQuadRenderer.Destroy;
begin
  FQuads.Free;

  inherited;
end;

procedure TAHMDXQuadRenderer.AllocateVertexBuffer;
var
  hr: HRESULT;
begin
  // Create our DirectX vertex buffer for rendering textured quads. Here we
  // allocate sufficient memory to store 6 vertices (for a quad) and specify
  // dynamic usage since we'll need to amend texture coordinate. Dynamic
  // vertex buffer must reside in default memory pool, hence we must release
  // and recreate it for lost device scenarios. Note we specify our custom
  // FVF flags which determines the format of the buffer contents.
  hr := DirectXInstance.DisplayDevice.CreateVertexBuffer(
          QUAD_CACHE_SIZE * FQuadSize, D3DUSAGE_DYNAMIC or D3DUSAGE_WRITEONLY,
          D3DFVF_CUSTOMVERTEX, D3DPOOL_DEFAULT, FVertexBuffer, nil);

  if hr <> S_OK then
    DirectXInstance.RaiseError('Failed to create DirectX Sprite Vertex buffer', hr);
end;

procedure TAHMDXQuadRenderer.ClearQuads;
var
  i: Integer;
  Quad: PQuadVertices;
begin
  // Free all of our quad vertices
  for i := 0 to Pred(FQuads.Count) do
  begin
    Quad := PQuadVertices(FQuads[i]);
    Dispose(Quad);
  end;

  // Clear list contents
  FQuads.Clear;
end;

function TAHMDXQuadRenderer.CreateQuad: PQuadVertices;
begin
  // Create new quad record & initialise
  New(Result);

  // Populate default vertices - full texture & no gamma correction
  CopyMemory(Result, @EMPTY_QUAD, FQuadSize);
end;

procedure TAHMDXQuadRenderer.RenderQuad(Quad: PQuadVertices; Texture: IDirect3DTexture9);
begin
  // If our buffer is full or we need to switch textures then flush buffer
  if (Texture <> FCacheTexture) or (Texture = nil) then
  begin
    FlushRenders;

    // Swap and cache our new texture
    DirectXInstance.DisplayDevice.SetTexture(0, Texture);
    FCacheTexture := Texture;
  end
  else if FQuads.Count = QUAD_CACHE_SIZE then
    FlushRenders;

  // Add this quad to our render list... we'll render in batches
  FQuads.Add(Quad);
end;

procedure TAHMDXQuadRenderer.FlushRenders;
var
  i: Integer;
  hr: HRESULT;
  pVertices: PQuadVertices;
begin
  // Do we have any outstanding quads to submit for rendering?
  if FQuads.Count > 0 then
  begin
    // Now we can lock and populate our vertex buffer. We specify discard
    // flag so that adapter can work on a parallel copy of the vertex buffer
    hr := FVertexBuffer.Lock(0, FQuads.Count * FQuadSize, Pointer(pVertices), D3DLOCK_DISCARD);
    if hr = D3D_OK then
    try
      // Populate all of our quad vertices
      for i := 0 to Pred(FQuads.Count) do
      begin
        CopyMemory(pVertices, FQuads[i], FQuadSize);
        Inc(pVertices);
      end;
    finally
      // Don't forget to unlock or we stall the adapter
      FVertexBuffer.Unlock;
    end;

    // Draw the triangles in the vertex buffer. This is broken into a few
    // steps. We are passing the vertices down a "stream", so first we need
    // to specify the source of that stream, which is our vertex buffer. Then
    // we need to let D3D know what vertex shader to use. Full, custom vertex
    // shaders are an advanced topic, but in most cases the vertex shader is
    // just the FVF, so that D3D knows what type of vertices we are dealing
    // with. Finally, we call DrawPrimitive() which does the actual rendering
    // of our geometry (in this case, just two triangles)
    if not FCachedVertex then
    begin
      DirectXInstance.DisplayDevice.SetStreamSource(0, FVertexBuffer, 0, FVertexSize);
      DirectXInstance.DisplayDevice.SetFVF(D3DFVF_CUSTOMVERTEX);
      FCachedVertex := True;
    end;

    // NB: we render two triangles per quad, so we double quad count below
    DirectXInstance.DisplayDevice.DrawPrimitive(D3DPT_TRIANGLELIST, 0, 2 * FQuads.Count);

    // Now clear our cache
    ClearQuads;
  end;
end;

procedure TAHMDXQuadRenderer.ClearVertexCache;
begin
  // Clear vertex and texture cache
  FCacheTexture := nil;
  FCachedVertex := False;
end;

procedure TAHMDXQuadRenderer.OnLostDevice;
begin
  // Abandon any pending quad renders
  ClearQuads;

  // Release cached texture interface
  FCacheTexture := nil;

  // Also need to release our vertex buffer
  FVertexBuffer := nil;
  FCachedVertex := False;
end;

procedure TAHMDXQuadRenderer.OnResetDevice;
begin
  // Create vertex buffer for use with quad renderer
  AllocateVertexBuffer;
end;

//----------------------------------------------------------------------------//

constructor TAHMDXSprite.Create;
begin
  inherited Create;

  // Enable sprite alpha blending by default
  FAlphaBlending := True;
  FMonochrome := False;
end;

destructor TAHMDXSprite.Destroy;
begin
  // Dereference our Texture COM object
  FTexture := nil;

  // Inform Sprite manager that we've been destroyed
  DirectXInstance.SpriteManager.FreeSprite(Self);

  inherited Destroy;
end;

function TAHMDXSprite.GetBounds: TAHMRect;
begin
  // Return bounds for texture updates
  Result := MakeRect(0, 0, FWidth, FHeight);
end;

function TAHMDXSprite.GetSourceRect: TAHMRectF;
begin
  // Return populated portion of texture for rendering
  Result := MakeRectF(0, 0, FWidth / FTextureWidth, FHeight / FTextureHeight);
end;

procedure TAHMDXSprite.SetDimensions(Width, Height: Integer);
begin
  if (FWidth <> Width) or (FHeight <> Height) then
  begin
    FWidth := Width;
    FHeight := Height;

    // Changing dimensions invalidates our texture
    FTexture := nil;
    FValid := False;
  end;
end;

function TAHMDXSprite.AllocateHandle: Boolean;
var
  hr: HRESULT;
  DXSurface: IDirect3DSurface9;
begin
  // Set default result - failed to allocate handle
  Result := False;

  // We must have a texture assigned to be able to allocate a handle
  if FTexture <> nil then
  begin
    // Get corresponding surface and allocate handle for GDI rendering
    hr := FTexture.GetSurfaceLevel(0, DXSurface);
    if hr <> D3D_OK then
      LogWarn('Failed to retrieve surface from sprite texture: ' + DXGetErrorString9(hr))
    else
    begin
      // Attempt to lock surface - use sparingly, and ALWAYS release!
      if DXSurface = nil then Exit;
      hr := DXSurface.GetDC(FSurfaceHandle);
      if hr <> D3D_OK then
        LogWarn('Failed to lock DirectX surface for GDI rendering: ' + DXGetErrorString9A(hr))
      else
        Result := True;
    end;
  end;
end;

procedure TAHMDXSprite.ReleaseHandle;
var
  hr: HRESULT;
  DXSurface: IDirect3DSurface9;
begin
  // We must have a texture assigned to be able to release handle
  if FTexture <> nil then
  begin
    // Get corresponding surface
    hr := FTexture.GetSurfaceLevel(0, DXSurface);
    if hr <> D3D_OK then
      LogWarn('Failed to retrieve surface from sprite texture: ' + DXGetErrorString9(hr))
    else
    begin
      if DXSurface = nil then Exit;
      DXSurface.ReleaseDC(FSurfaceHandle);
    end;
  end;
end;

function TAHMDXSprite.AllocateTexture: IDirect3DTexture9;
var
  DXFormat: TD3DFormat;
  DXTexture: IDirect3DTexture9;
  DXDescriptor: TD3DSurfaceDesc;
  hr: HRESULT;
begin
  // If we don't have a valid texture then we need to repopulate the texture
  if (FTexture = nil) and not FValid then
  begin
    // Set required texture format
    if FMonochrome then DXFormat := DirectXInstance.MonochromeFormat
    else if FAlphaBlending then DXFormat := DirectXInstance.AlphaFormat
    else DXFormat := DirectXInstance.NonAlphaFormat;

    // Ensure current texture is free'd first
    FTexture := nil;

    hr := D3DXCreateTexture(DirectXInstance.DisplayDevice, FWidth, FHeight,
                            1, 0, DXFormat, D3DPOOL_MANAGED, DXTexture);
    if hr <> D3D_OK then
      LogWarn('Failed to create DirectX texture for rendering: ' + DXGetErrorString9(hr))
    else
    begin
      // Success, cache our new DirectX texture
      FTexture := DXTexture;

      // Did we get the texture format we wanted?
      hr := DXTexture.GetLevelDesc(0, DXDescriptor);
      if hr <> D3D_OK then
        LogWarn('Failed to retrieve description of DirectX rendering texture: ' + DXGetErrorString9(hr))
      else
      begin
        FTextureWidth := DXDescriptor.Width;
        FTextureHeight := DXDescriptor.Height;
        if (FTextureWidth < FWidth) or (FTextureHeight < FHeight) then
        begin
          LogWarn('Unexpected DirectX rendering texture size returned: ' +
                  IntToStr(FTextureWidth) + 'x' + IntToStr(FTextureHeight) +
                  ', requested ' + IntToStr(FWidth) + 'x' + IntToStr(FHeight));
          FTexture := nil;
        end;

        FTextureFmt := DXDescriptor.Format;
        if FTextureFmt <> DXFormat then
        begin
          LogWarn('Unexpected DirectX rendering texture format returned: ' +
            DirectXInstance.FormatToString(FTextureFmt) + ', expected: ' +
            DirectXInstance.FormatToString(DXFormat));
          FTexture := nil;
        end;
      end;
    end;

    // Don't try to recreate texture again
    FValid := True;
  end;

  // Return our cached texture (or nil if creation failed)
  Result := FTexture
end;

function TAHMDXSprite.AllocateVideoTexture(Format: TD3DFormat; Pool: TD3DPool): IDirect3DTexture9;
var
  DXTexture: IDirect3DTexture9;
  DXDescriptor: TD3DSurfaceDesc;
  hr: HRESULT;
begin
  // Set default result - failed to create texture
  Result := nil;
  FTexture := nil;

  // Create specified texture format in requested pool. We specify a dynamic
  // texture hint since we'll be updating it repeatedly with our video frames
  hr := D3DXCreateTexture(DirectXInstance.DisplayDevice, FWidth, FHeight,
                          1, D3DUSAGE_DYNAMIC, Format, Pool, DXTexture);

  if hr <> D3D_OK then
    LogWarn('Failed to create DirectX texture for video rendering: ' + DXGetErrorString9(hr))
  else
  begin
    // Success, cache our new DirectX texture
    FTexture := DXTexture;
    Result := DXTexture;

    // Retrieve dimensions of texture for rendering later
    DXTexture.GetLevelDesc(0, DXDescriptor);
    FTextureWidth := DXDescriptor.Width;
    FTextureHeight := DXDescriptor.Height;
    FTextureFmt := DXDescriptor.Format;
  end;

  // Don't try to recreate texture again when we render - even if we failed
  FValid := True;
end;

procedure TAHMDXSprite.SaveToFile(Filename: String);
var
  hr: HRESULT;
begin
  if FTexture <> nil then
  begin
    hr := D3DXSaveTextureToFile(PAnsiChar(Filename), D3DXIFF_PNG, FTexture, Nil);
    if hr <> D3D_OK then
      LogDebug('Failed to save DirectX texture to file "' + Filename + '": ' + DXGetErrorString9(hr))
  end;
end;

procedure TextureFillFunction(out pOut: TD3DXVector4; const pTexCoord, pTexelSize: TD3DXVector2; var pData); stdcall;
begin
  // We get passed a TD3DXVector4 from method below which is prepopulated with fixed colour
  pOut := TD3DXVector4(pData);
end;

procedure TAHMDXSprite.ClearTexture;
var
  hr: HRESULT;
  FillColour: TD3DXVector4;
begin
  if FTexture <> nil then
  begin
    // Fill our texture using D3DX method and our fill function above
    FillColour := D3DXVector4($00, $00, $00, $00); // Order is RGBA
    hr := D3DXFillTexture(FTexture, @TextureFillFunction, @FillColour);
    if hr <> D3D_OK then
      LogDebug('Failed to clear DirectX texture: ' + DXGetErrorString9(hr));
  end;
end;

//----------------------------------------------------------------------------//

constructor TAHMDXSpriteManager.Create;
begin
  inherited Create;

  FSpriteList := TList.Create;
  FQuadRenderer := TAHMDXQuadRenderer.Create;
end;

destructor TAHMDXSpriteManager.Destroy;
begin
  FSpriteList.Free;
  FQuadRenderer.Free;

  inherited Destroy;
end;

function TAHMDXSpriteManager.GetDXSprite(Index: Integer): TAHMDXSprite;
begin
  Result := TAHMDXSprite(FSpriteList.Items[Index]);
end;

function TAHMDXSpriteManager.GetCount: Integer;
begin
  Result := FSpriteList.Count;
end;

procedure TAHMDXSpriteManager.ReleaseTextures;
var
  i: Integer;
begin
  // Release all DirectX texture interfaces currently held
  for i := 0 to Pred(FSpriteList.Count) do
    with GetDXSprite(i) do
    begin
      Texture := nil;
      // If sprite dimensions are stored then our texture was valid, but needs
      // to be reloaded or recopied from GDI buffer next time we render the sprite.
      if (Width > 0) and (Height > 0) then
        Valid := False;
    end;
end;

procedure TAHMDXSpriteManager.FreeSprite(Sprite: TAHMDXSprite);
var
  i: Integer;
begin
  // If passed sprite object is found in our list then remove it
  i := FSpriteList.IndexOf(Sprite);
  if i <> -1 then FSpriteList.Delete(i);
end;

function TAHMDXSpriteManager.CreateSprite: TAHMDXSprite;
begin
  // Defer to function below
  Result := CreateSprite(-1, -1);
end;

function TAHMDXSpriteManager.CreateSprite(Width, Height: Integer): TAHMDXSprite;
begin
  // Set default result - sprite not created
  Result := nil;

  // If width & height are valid we are ready to draw sprite
  if (Width <> 0) and (Height <> 0) then
  begin
    Result := TAHMDXSprite.Create;
    Result.SetDimensions(Width, Height);
    FSpriteList.Add(Result);
  end
  else
    LogWarn('Create sprite method was passed invalid dimensions');
end;

function TAHMDXSpriteManager.CreateSpriteFromGraphic(Graphic: TAHMGraphic): TAHMDXSprite;
begin
  // Set default result - sprite not created
  Result := nil;
  if not Assigned(Graphic) then Exit;

  // Create a sprite descriptor for graphic image
  Result := TAHMDXSprite.Create;
  Result.SetDimensions(Graphic.ImageWidth, Graphic.ImageHeight);
  FSpriteList.Add(Result);
end;

function TAHMDXSpriteManager.UpdateSprite(Sprite: TAHMDXSprite; BitmapData: TAHMBitmapData): Boolean;
var
  Texture: IDirect3DTexture9;
  TextureFmt: TAHMTextureFormat;
  Width, Height, ByteWidth, i, j: Integer;
  LockInfo: TD3DLockedRect;
  Source, Destination: TAHMBytePointer;
  SScanLine32: PPixelArray;
  DScanLine32: PPixelArray;
  SScanLine16: P16bitPixelArray;
  DScanLine16: P16bitPixelArray;
  hr: HRESULT;
begin
  Result := False;

  // We must have a texture allocated before we can draw to sprite
  if not Assigned(Sprite) then Exit;
  Texture := Sprite.AllocateTexture;
  TextureFmt := DirectXInstance.FormatBits(Sprite.TextureFormat);

  if Assigned(Texture) then
  begin
    // Lock the texture surface, clipping size to smallest dimension
    Width := Min(BitmapData.Width, Sprite.Width);
    Height := Min(BitmapData.Height, Sprite.Height);
    hr := Texture.LockRect(0, LockInfo, nil, 0);
    if hr <> D3D_OK then
      LogWarn('Failed to lock sprite texture surface: ' + DXGetErrorString9A(hr))
    else
    begin
      // Now we can copy lines from source bitmap to destination surface
      Source := BitmapData.PixelData;
      Destination := LockInfo.pBits;
      ByteWidth := Width * BitmapData.BytesPerPixel;

      // Copy method depends on source & destination formats
      if Sprite.Monochrome and (TextureFmt = tf16Bit) then
      begin
        // Monochrome - downsample A8R8G8B8 bitmap to A8L8 texture format
        for i := 0 to Pred(Height) do
        begin
          SScanLine32 := PPixelArray(Source);
          DScanLine16 := P16bitPixelArray(Destination);
          for j := 0 to Pred(Width) do
            DScanLine16[j] := (SScanLine32[j][ctAlpha] shl 8) or SScanLine32[j][ctRed];
          Inc(Destination, LockInfo.Pitch);
          Inc(Source, BitmapData.RowDelta);
        end;
      end
      else if (BitmapData.BytesPerPixel = 4) and (TextureFmt = tf16Bit) then
      begin
        // Downsample A8R8G8B8 bitmap for 16bit texture format :-(
        for i := 0 to Pred(Height) do
        begin
          SScanLine32 := PPixelArray(Source);
          DScanLine16 := P16bitPixelArray(Destination);
          for j := 0 to Pred(Width) do
            case Sprite.TextureFormat of
              D3DFMT_X1R5G5B5, D3DFMT_A1R5G5B5:
                DScanLine16[j] := ((SScanLine32[j][ctAlpha] and $80) shl 8) or
                                  ((SScanLine32[j][ctRed] and $F8) shl 7) or
                                  ((SScanLine32[j][ctGreen] and $F8) shl 2) or
                                  (SScanLine32[j][ctBlue] shr 3);
              D3DFMT_A4R4G4B4, D3DFMT_X4R4G4B4:
                DScanLine16[j] := ((SScanLine32[j][ctAlpha] and $F0) shl 8) or
                                  ((SScanLine32[j][ctRed] and $F0) shl 4) or
                                  (SScanLine32[j][ctGreen] and $F0) or
                                  (SScanLine32[j][ctBlue] shr 4);
              D3DFMT_R5G6B5:
                DScanLine16[j] := ((SScanLine32[j][ctRed] and $F8) shl 8) or
                                  ((SScanLine32[j][ctGreen] and $FC) shl 3) or
                                  (SScanLine32[j][ctBlue] shr 3);
            end;
          Inc(Destination, LockInfo.Pitch);
          Inc(Source, BitmapData.RowDelta);
        end;
      end
      else if (BitmapData.BytesPerPixel = 2) and (TextureFmt = tf32Bit) then
      begin
        // Upsample A1R5G5B5 bitmap to A8R8G8B8 format :-) (but why?)
        for i := 0 to Pred(Height) do
        begin
          SScanLine16 := P16bitPixelArray(Source);
          DScanLine32 := PPixelArray(Destination);
          for j := 0 to Pred(Width) do
          begin
            DScanLine32[j][ctAlpha] := (SScanLine16[j] and $8000) shr 8;
            DScanLine32[j][ctRed]   := (SScanLine16[j] and $7c00) shr 7;
            DScanLine32[j][ctGreen] := (SScanLine16[j] and $03e0) shr 2;
            DScanLine32[j][ctBlue]  := (SScanLine16[j] and $001f) shl 3;
          end;
          Inc(Destination, LockInfo.Pitch);
          Inc(Source, BitmapData.RowDelta);
        end;
      end
      else
      begin
        // Simple case - source & destination formats have same no. of bits
        for i := 0 to Pred(Height) do
        begin
          CopyMemory(Destination, Source, ByteWidth);
          Inc(Destination, LockInfo.Pitch);
          Inc(Source, BitmapData.RowDelta);
        end;
      end;

      // Unlock texture surface
      hr := Texture.UnlockRect(0);
      if hr <> D3D_OK then
        LogWarn('Failed to unlock sprite texture surface: ' + DXGetErrorString9A(hr))
      else
        Result := True; // Success
    end;
  end;
end;

procedure TAHMDXSpriteManager.SetRotation(XOrigin, YOrigin: Single);
begin
  // Flush any outstanding quads before changing rotation origin
  FlushSprites;
  FCachedWorld := True;
  FCachedOriginX := XOrigin;
  FCachedOriginY := YOrigin;
end;

procedure TAHMDXSpriteManager.Set3DRotation(Rotation: TD3DMatrix);
begin
  if not F3DRotation then
  begin
    // Flush any outstanding quads before switching to 3D rotation mode
    FlushSprites;
    F3DRotation := True;

    // Setup default identity translation
    F3DOriginX := 0.0;
    F3DOriginY := 0.0;
  end;

  // Cache 3D rotation matrix
  F3DRotnMatrix := Rotation;
end;

procedure TAHMDXSpriteManager.Set3DTranslation(XOrigin, YOrigin: Single);
begin
  if not F3DRotation then
  begin
    // Flush any outstanding quads before switching to 3D rotation mode
    FlushSprites;
    F3DRotation := True;

    // Setup default identity rotation matrix
    D3DXMatrixIdentity(F3DRotnMatrix);
  end;

  // Cache 3D translation properties
  F3DOriginX := XOrigin;
  F3DOriginY := YOrigin;
end;

procedure TAHMDXSpriteManager.ResetRotation;
begin
  // Flush outstanding quads and reset our world transformation
  FlushSprites;
  FCachedWorld := False;
end;

procedure TAHMDXSpriteManager.Reset3DRotation;
begin
  // Reset 3D rotation mode (quads flushed on each render)
  F3DRotation := False;
end;

procedure TAHMDXSpriteManager.DrawSprite(Sprite: TAHMDXSprite; SrcRect, DestRect, ClipRect: TAHMRectF; Shade: TAHMCanvasShade;
                                         Gamma: TAHMCanvasColour; XScale, YScale: Single; XFlip, YFlip, Clip: Boolean);
var
  DXTexture: IDirect3DTexture9;
  Quad: PQuadVertices;
  ClipOffset, ClipScale: Single;
  matTrans, matScale, matWorld: TD3DMatrix;
begin
  // Skip rendering unless called within Begin/End setup pair
  if not FInitialised then Exit;

  // Allocate a directX texture object to perform rendering
  if Assigned(Sprite) then DXTexture := Sprite.AllocateTexture
                      else DXTexture := nil;

  // Ensure our sprite has a non-zero sized texture allocated
  if Assigned(Sprite) and ((Sprite.TextureWidth = 0) or (Sprite.TextureHeight = 0)) then Exit;

  // Determine whether we want to use pixel clipping
  if Clip then
  begin
    // Calculate horizontal pixel clipping
    if DestRect.X + DestRect.Width < ClipRect.X then
    begin
      // Sprite is left of clipping area so don't draw
      Exit;
    end
    else if DestRect.X > ClipRect.X + ClipRect.Width then
    begin
      // Sprite is right of clipping area so don't draw
      Exit;
    end
    else
    begin
      // First check for partial clipping of right edge
      if DestRect.X + DestRect.Width > ClipRect.X + ClipRect.Width then
      begin
        ClipOffset := ClipRect.X + ClipRect.Width - DestRect.X;
        ClipScale := SrcRect.Width / DestRect.Width;
        DestRect.Width := ClipOffset;
        if Assigned(Sprite) then SrcRect.Width := ClipOffset * ClipScale;
      end;

      // Then check for partial clipping of left edge (in case we need both)
      if DestRect.X < ClipRect.X then
      begin
        // Sprite is partially clipped to left
        ClipOffset := ClipRect.X - DestRect.X;
        ClipScale := SrcRect.Width / DestRect.Width;
        DestRect.X := DestRect.X + ClipOffset;
        DestRect.Width := DestRect.Width - ClipOffset;
        if Assigned(Sprite) then
        begin
          SrcRect.X := SrcRect.X + (ClipOffset * ClipScale);
          SrcRect.Width := SrcRect.Width - (ClipOffset * ClipScale);
        end;
      end;
    end;

    // Calculate vertical pixel clipping
    if DestRect.Y + DestRect.Height < ClipRect.Y then
    begin
      // Sprite is above clipping area so don't draw
      Exit;
    end
    else if DestRect.Y > ClipRect.Y + ClipRect.Height then
    begin
      // Sprite is below clipping area so don't draw
      Exit;
    end
    else
    begin
      // First check for partial clipping of bottom
      if DestRect.Y + DestRect.Height > ClipRect.Y + ClipRect.Height then
      begin
        // Sprite is partially clipped below
        ClipOffset := ClipRect.Y + ClipRect.Height - DestRect.Y;
        ClipScale := SrcRect.Height / DestRect.Height;
        DestRect.Height := ClipOffset;
        if Assigned(Sprite) then SrcRect.Height := ClipOffset * ClipScale;
      end;

      // Then check for partial clipping of top edge (in case we need both)
      if DestRect.Y < ClipRect.Y then
      begin
        // Sprite is partially clipped above
        ClipOffset := ClipRect.Y - DestRect.Y;
        ClipScale := SrcRect.Height / DestRect.Height;
        DestRect.Y := DestRect.Y + ClipOffset;
        DestRect.Height := DestRect.Height - ClipOffset;
        if Assigned(Sprite) then
        begin
          SrcRect.Y := SrcRect.Y + (ClipOffset * ClipScale);
          SrcRect.Height := SrcRect.Height - (ClipOffset * ClipScale);
        end;
      end;
    end;
  end;

  // Allocate a new Quad rendering instance
  Quad := FQuadRenderer.CreateQuad;

  // Apply gamma colouring & shading if required
  if Assigned(Shade) and Shade.Valid then
  begin
    Shade.ShadeRect(DestRect);
    Quad[0].Colour := Shade.TopRight.InternalGammaCorrect(Gamma);
    Quad[1].Colour := Shade.BottomRight.InternalGammaCorrect(Gamma);
    Quad[2].Colour := Shade.BottomLeft.InternalGammaCorrect(Gamma);
    Quad[3].Colour := Quad[2].Colour;
    Quad[4].Colour := Shade.TopLeft.InternalGammaCorrect(Gamma);
    Quad[5].Colour := Quad[0].Colour;
  end
  else if Assigned(Gamma) then
  begin
    Quad[0].Colour := Gamma.InternalARGB;
    Quad[1].Colour := Quad[0].Colour;
    Quad[2].Colour := Quad[0].Colour;
    Quad[3].Colour := Quad[0].Colour;
    Quad[4].Colour := Quad[0].Colour;
    Quad[5].Colour := Quad[0].Colour;
  end;

  // Are we using full 3D rotation mode for rendering?
  if F3DRotation then
  begin
    // Calculate scaling factors for scaling matrix
    if XFlip then XScale := -XScale * DestRect.Width
             else XScale := XScale * DestRect.Width;
    if YFlip then YScale := -YScale * DestRect.Height
             else YScale := YScale * DestRect.Height;

    // Build a scaling matrix to scale model to world coordinates
    D3DXMatrixScaling(matScale, XScale, YScale, 1.0);

    // Build a transformation matrix to position rotation origin
    D3DXMatrixTranslation(matTrans, F3DOriginX, F3DOriginY, 0.0);

    // Combine scale and rotation matrix to perform scaling
    D3DXMatrixMultiply(matTrans, matTrans, matScale);

    // Combine translation and rotation matrix to perform 3D rotation
    D3DXMatrixMultiply(matWorld, matTrans, F3DRotnMatrix);

    // Apply inverse transformation matrix to restore rotation origin
    D3DXMatrixTranslation(matTrans, 1 - (DestRect.X * 2),
                                    1 - (DestRect.Y * 2), 0.0);
    D3DXMatrixMultiply(matWorld, matWorld, matTrans);

    // Apply new world matrix to DirectX device
    DirectXInstance.DisplayDevice.SetTransform(D3DTS_WORLD, matWorld);
  end
  else
  begin
    // Calculate transformed world space coordinates for our shape
    DestRect.X := 1 - ((DestRect.X * 2) + DestRect.Width);
    DestRect.Y := 1 - ((DestRect.Y * 2) + DestRect.Height);

    // Correct origin if we're using a world transformation for rotation
    if FCachedWorld then
    begin
      DestRect.X := DestRect.X - FCachedOriginX;
      DestRect.Y := DestRect.Y - FCachedOriginY;
    end;

    // We don't use scaling transform so width & height always set in world space
    with DestRect do
    begin
      if XFlip then Width := -Width * XScale else Width := Width * XScale;
      if YFlip then Height := -Height * YScale else Height := Height * YScale;
    end;

    // Apply custom quad coordinates
    Quad[0].X := DestRect.X - DestRect.Width;
    Quad[0].Y := DestRect.Y - DestRect.Height;
    Quad[1].X := Quad[0].X;
    Quad[1].Y := DestRect.Y + DestRect.Height;
    Quad[2].X := DestRect.X + DestRect.Width;
    Quad[2].Y := Quad[1].Y;
    Quad[3].X := Quad[2].X;
    Quad[3].Y := Quad[2].Y;
    Quad[4].X := Quad[2].X;
    Quad[4].Y := Quad[0].Y;
    Quad[5].X := Quad[0].X;
    Quad[5].Y := Quad[0].Y;
  end;

  // Apply custom texture coordinates - vertices are clockwise from top right
  if Assigned(Sprite) then
  begin
    Quad[0].Tu := SrcRect.X + SrcRect.Width;
    Quad[0].Tv := SrcRect.Y + SrcRect.Height;
    Quad[1].Tu := Quad[0].Tu;
    Quad[1].Tv := SrcRect.Y;
    Quad[2].Tu := SrcRect.X;
    Quad[2].Tv := Quad[1].Tv;
    Quad[3].Tu := Quad[2].Tu;
    Quad[3].Tv := Quad[2].Tv;
    Quad[4].Tu := Quad[2].Tu;
    Quad[4].Tv := Quad[0].Tv;
    Quad[5].Tu := Quad[0].Tu;
    Quad[5].Tv := Quad[0].Tv;
  end;

  // Now submit our quad to the rendering batch
  FQuadRenderer.RenderQuad(Quad, DXTexture);
  if F3DRotation then FlushSprites;
end;

procedure TAHMDXSpriteManager.DrawSprite(Sprite: TAHMDXSprite; SrcRect: TAHMRectF;
                                         X1, Y1, X2, Y2, X3, Y3, X4, Y4: Single;
                                         Shade: TAHMCanvasShade; Gamma: TAHMCanvasColour);
var
  DXTexture: IDirect3DTexture9;
  Quad: PQuadVertices;
begin
//TODO - take account of 3D rotation mode here.. if we ever use this method
  // Skip rendering unless called within Begin/End setup pair
  if not FInitialised then Exit;

  // Allocate a directX texture object to perform rendering
  if Assigned(Sprite) then DXTexture := Sprite.AllocateTexture
                      else DXTexture := nil;

  // Ensure our sprite has a non-zero sized texture allocated
  if Assigned(Sprite) and ((Sprite.TextureWidth = 0) or (Sprite.TextureHeight = 0)) then Exit;

  // Allocate a new Quad rendering instance
  Quad := FQuadRenderer.CreateQuad;

  // Apply gamma colouring & shading if required
  if Assigned(Shade) and Shade.Valid then
  begin
    Quad[0].Colour := Shade.TopRight.InternalGammaCorrect(Gamma);
    Quad[1].Colour := Shade.BottomRight.InternalGammaCorrect(Gamma);
    Quad[2].Colour := Shade.BottomLeft.InternalGammaCorrect(Gamma);
    Quad[3].Colour := Quad[2].Colour;
    Quad[4].Colour := Shade.TopLeft.InternalGammaCorrect(Gamma);
    Quad[5].Colour := Quad[0].Colour;
  end
  else if Assigned(Gamma) then
  begin
    Quad[0].Colour := Gamma.InternalARGB;
    Quad[1].Colour := Quad[0].Colour;
    Quad[2].Colour := Quad[0].Colour;
    Quad[3].Colour := Quad[0].Colour;
    Quad[4].Colour := Quad[0].Colour;
    Quad[5].Colour := Quad[0].Colour;
  end;

  // Convert model space coordinates to world space (-1..1)
  with ScreenInstance do
  begin
    // Calculate transformed world space coordinates for our shape
    X1 := 1 - (X1 * 2); Y1 := 1 - (Y1 * 2);
    X2 := 1 - (X2 * 2); Y2 := 1 - (Y2 * 2);
    X3 := 1 - (X3 * 2); Y3 := 1 - (Y3 * 2);
    X4 := 1 - (X4 * 2); Y4 := 1 - (Y4 * 2);

    // Correct origin if we're using a world transformation for rotation
    if FCachedWorld then
    begin
      X1 := X1 - FCachedOriginX; Y1 := Y1 - FCachedOriginY;
      X2 := X2 - FCachedOriginX; Y2 := Y2 - FCachedOriginY;
      X3 := X3 - FCachedOriginX; Y3 := Y3 - FCachedOriginY;
      X4 := X4 - FCachedOriginX; Y4 := Y4 - FCachedOriginY;
    end;
  end;

  // Apply custom quad coordinates
  Quad[0].X := X2; Quad[0].Y := Y2;
  Quad[1].X := X3; Quad[1].Y := Y3;
  Quad[2].X := X4; Quad[2].Y := Y4;
  Quad[3].X := X4; Quad[3].Y := Y4;
  Quad[4].X := X1; Quad[4].Y := Y1;
  Quad[5].X := X2; Quad[5].Y := Y2;

  // Apply custom texture coordinates - vertices are clockwise from top right
  if Assigned(Sprite) then
  begin
    Quad[0].Tu := (SrcRect.X + SrcRect.Width - 0.5) / Sprite.TextureWidth;
    Quad[0].Tv := (SrcRect.Y + SrcRect.Height - 0.5) / Sprite.TextureHeight;
    Quad[1].Tu := (SrcRect.X + SrcRect.Width - 0.5) / Sprite.TextureWidth;
    Quad[1].Tv := (SrcRect.Y + 0.5) / Sprite.TextureHeight;
    Quad[2].Tu := (SrcRect.X + 0.5) / Sprite.TextureWidth;
    Quad[2].Tv := (SrcRect.Y + 0.5) / Sprite.TextureHeight;
    Quad[3].Tu := Quad[2].Tu;
    Quad[3].Tv := Quad[2].Tv;
    Quad[4].Tu := (SrcRect.X + 0.5) / Sprite.TextureWidth;
    Quad[4].Tv := (SrcRect.Y + SrcRect.Height - 0.5) / Sprite.TextureHeight;
    Quad[5].Tu := Quad[0].Tu;
    Quad[5].Tv := Quad[0].Tv;
  end;

  // Now submit our quad to the rendering batch
  FQuadRenderer.RenderQuad(Quad, DXTexture);
end;

procedure TAHMDXSpriteManager.DrawPlainQuad(DestRect: TAHMRectF; Shade: TAHMCanvasShade;
                                            Gamma: TAHMCanvasColour; XScale, YScale: Single);
begin
  // Use method above but with a nil sprite
  DrawSprite(nil, DestRect, DestRect, EmptyRectF, Shade, Gamma, XScale, YScale, False, False, False);
end;

procedure TAHMDXSpriteManager.DrawPlainQuad(DestRect, ClipRect: TAHMRectF; Shade: TAHMCanvasShade;
                                            Gamma: TAHMCanvasColour; XScale, YScale: Single);
begin
  // Use method above but with a nil sprite
  DrawSprite(nil, DestRect, DestRect, ClipRect, Shade, Gamma, XScale, YScale, False, False, True);
end;

procedure TAHMDXSpriteManager.OnLostDevice;
begin
  // Ensure we release textures from all of our sprites
  ReleaseTextures;

  // Inform quad renderer of lost device event
  FQuadRenderer.OnLostDevice;

  // Reset our cached world transformation flag
  FCachedWorld := False;
  FInitialised := False;
end;

procedure TAHMDXSpriteManager.FlushSprites;
begin
  // Flush any outstanding sprite render requests
  FQuadRenderer.FlushRenders;
end;

procedure TAHMDXSpriteManager.OnResetDevice;
begin
  // Inform quad renderer of reset device event
  FQuadRenderer.OnResetDevice;
end;

procedure TAHMDXSpriteManager.ReleaseResources;
begin
  // Call OnLost device method to free textures
  OnLostDevice;
end;

procedure TAHMDXSpriteManager.BeginDrawing;
begin
  // Renderer will need to reset device state
  FQuadRenderer.ClearVertexCache;
  FInitialised := True;
end;

procedure TAHMDXSpriteManager.EndDrawing;
begin
  // Flush any outstanding rendering & clear device state
  FlushSprites;
  FInitialised := False;
end;


end.
